home *** CD-ROM | disk | FTP | other *** search
/ Technotools / Technotools (Chestnut CD-ROM)(1993).ISO / lang_oth / forchek1 / symtab2.c < prev    next >
C/C++ Source or Header  |  1991-11-05  |  35KB  |  1,217 lines
  1. /* symtab2.c:
  2.  
  3.  Contains two formerly independent files:
  4.     I.  exprtype.c -- propagates datatype thru expressions.
  5.     II. project.c  -- project-file I/O routines.
  6.  
  7.     Copyright (C) 1991 by Robert K. Moniot.
  8.     This program is free software.  Permission is granted to
  9.     modify it and/or redistribute it, retaining this notice.
  10.     No guarantees accompany this software.
  11.  
  12.  
  13. */
  14.  
  15. /* I. */
  16.  
  17. /*  exprtype.c:
  18.  
  19.  Routines to propagate datatype through expressions.
  20.  
  21.  binexpr_type()  Yields result type of binary expression.
  22.  unexpr_type()  Yields result type of unary expression.
  23.  assignment_stmt_type() Checks assignment statement type.
  24.  func_ref_expr(id,args,result) Forms token for a function invocation.
  25.  primary_id_expr() Forms token for primary which is an identifier.
  26.     int int_power(x,n)  Computes x**n for value propagation.
  27. */
  28.  
  29. #include <stdio.h>
  30. #include <string.h>
  31. #include "forchek.h"
  32. #include "symtab.h"
  33. #include "tokdefs.h"
  34.  
  35. PRIVATE int int_power();
  36.  
  37.  /* shorthand for datatypes.  must match those in symtab.h */
  38.  
  39. #define E 0 /*  Error for invalid type combos  */
  40. #define I 1
  41. #define R 2
  42. #define D 3
  43. #define C 4
  44. #define L 5
  45. #define S 6
  46. #define H 7
  47.  
  48. #define W -  /*  Warning for nonstandard type combos */
  49.  
  50.    /* for  + - / * ** ANSI book pp. 6-5,6-6 */
  51. char arith_expr_type[8][8]={
  52. /*E   I   R   D   C   L   S   H   */
  53. { E,  E,  E,  E,  E,  E,  E,  E }, /* E */
  54. { E,  I,  R,  D,  C,  E,  E,  E }, /* I */
  55. { E,  R,  R,  D,  C,  E,  E,  E }, /* R */
  56. { E,  D,  D,  D,  E,  E,  E,  E }, /* D */
  57. { E,  C,  C,  E,  C,  E,  E,  E }, /* C */
  58. { E,  E,  E,  E,  E,  E,  E,  E }, /* L */
  59. { E,  E,  E,  E,  E,  E,  E,  E }, /* S */
  60. { E,  E,  E,  E,  E,  E,  E,  E } /* H */
  61. };
  62.  
  63.    /* for  relops.  Corresponds to arith type table
  64.       except that nonstandard comparisons of like
  65.       types have warning, not error. */
  66. char rel_expr_type[8][8]={
  67. /*E   I   R   D   C   L   S   H   */
  68. { E,  E,  E,  E,  E,  E,  E,  E }, /* E */
  69. { E,  L,  L,  L,  L,  E,  E,W L }, /* I */
  70. { E,  L,  L,  L,  L,  E,  E,  E }, /* R */
  71. { E,  L,  L,  L,  E,  E,  E,  E }, /* D */
  72. { E,  L,  L,  E,  L,  E,  E,  E }, /* C */
  73. { E,  E,  E,  E,  E,W L,  E,W L }, /* L */
  74. { E,  E,  E,  E,  E,  E,  L,  E }, /* S */
  75. { E,W L,  E,  E,  E,W L,  E,W L } /* H */
  76. };
  77.  
  78.    /* Result of assignment:  lvalue = expr.  Here rows
  79.       correspond to type of lvalue, columns to type
  80.       of expr */
  81. char assignment_type[8][8]={
  82. /*E   I   R   D   C   L   S   H   */
  83. { E,  E,  E,  E,  E,  E,  E,  E }, /* E */
  84. { E,  I,  I,  I,  I,  E,  E,W I }, /* I */
  85. { E,  R,  R,  R,  R,  E,  E,  E }, /* R */
  86. { E,  D,  D,  D,  D,  E,  E,  E }, /* D */
  87. { E,  C,  C,  C,  C,  E,  E,  E }, /* C */
  88. { E,  E,  E,  E,  E,  L,  E,W L }, /* L */
  89. { E,  E,  E,  E,  E,  E,  S,  E }, /* S */
  90. { E,  E,  E,  E,  E,  E,  E,  E } /* H not possible for lvalue */
  91. };
  92.  
  93.  /* this routine propagates type in binary expressions */
  94.  
  95. void
  96. binexpr_type(term1,operator,term2,result)
  97.  Token *term1, *operator, *term2, *result;
  98. {
  99.     int op = operator->class,
  100.  type1 = datatype_of(term1->class),
  101.  type2 = datatype_of(term2->class),
  102.  result_type;
  103.  
  104.     if( ! is_computational_type(type1) ) {
  105.   syntax_error(term1->line_num,term1->col_num,
  106.    "noncomputational primary in expression");
  107.   result_type = E;
  108.     }
  109.     else if( ! is_computational_type(type2) ) {
  110.   syntax_error(term2->line_num,term2->col_num,
  111.    "noncomputational primary in expression");
  112.   result_type = E;
  113.     }
  114.     else {
  115.  switch(op) {
  116.     /* arithmetic operators: use lookup table */
  117.      case '+':
  118.      case '-':
  119.      case '*':
  120.      case '/':
  121.      case tok_power:
  122.   result_type = arith_expr_type[type1][type2];
  123.   break;
  124.  
  125.     /* relational operators: use lookup table */
  126.       case tok_relop:
  127.   result_type = rel_expr_type[type1][type2];
  128.   break;
  129.  
  130.     /*  logical operators: operands should be
  131.         logical, but allow integers with a
  132.         warning. */
  133.      case tok_AND:
  134.      case tok_OR:
  135.      case tok_EQV:
  136.      case tok_NEQV:
  137.   if(type1 == L && type2 == L)
  138.       result_type = L;
  139.   else if(type1 == I && type2 == I)
  140.       result_type = W I;
  141.   else
  142.       result_type = E;
  143.   break;
  144.  
  145.     /*  // operator: operands must be strings */
  146.      case tok_concat:
  147.   if(type1 == S && type2 == S)
  148.       result_type = S;
  149.   else
  150.       result_type = E;
  151.   break;
  152.  
  153.      default:
  154.   syntax_error(operator->line_num,operator->col_num,
  155.    "oops--operator unknown: type not propagated");
  156.   result_type = type1;
  157.   break;
  158.  }
  159.  
  160.  if( (type1 != E && type2 != E) )
  161.      if( result_type == E) {
  162.   syntax_error(operator->line_num,operator->col_num,
  163.    "type mismatch in expression");
  164.      }
  165.      else if(result_type < 0) {  /* W result */
  166.   warning(operator->line_num,operator->col_num,
  167.    "nonstandard type combination in expression");
  168.   result_type = -result_type;
  169.      }
  170.     }
  171.  
  172.     result->class = type_byte(class_VAR, result_type);
  173.     result->subclass = 0; /* clear all flags */
  174.  
  175.   /* Keep track of constant expressions */
  176.     if( is_true(CONST_EXPR,term1->subclass)
  177.   && is_true(CONST_EXPR,term2->subclass)  ) {
  178.   make_true(CONST_EXPR,result->subclass);
  179.     }
  180.  
  181.   /* Remember if integer division was used */
  182.     if(result_type == type_INTEGER &&
  183.     (op == '/' ||
  184.      (is_true(INT_QUOTIENT_EXPR,term1->subclass) ||
  185.       is_true(INT_QUOTIENT_EXPR,term2->subclass))) ) {
  186.   make_true(INT_QUOTIENT_EXPR,result->subclass);
  187.     }
  188.  
  189.   /* Issue warning if integer expr involving division is
  190.      later converted to any real type, or if it is used
  191.      as an exponent. */
  192.     if( is_true(INT_QUOTIENT_EXPR,term1->subclass)
  193.  || is_true(INT_QUOTIENT_EXPR,term2->subclass) ) {
  194.  
  195.  int r=result_type;
  196.  if(r == type_LOGICAL)  /* relational tests are equivalent */
  197.      r = arith_expr_type[type1][type2];  /* to subtraction */
  198.  
  199.  if(op == tok_power && is_true(INT_QUOTIENT_EXPR,term2->subclass) ) {
  200.      warning(operator->line_num,operator->col_num,
  201.    "integer quotient expr used in exponent");
  202.      if( ! is_true(INT_QUOTIENT_EXPR,term1->subclass) )
  203.   make_false(INT_QUOTIENT_EXPR,result->subclass);
  204.  }
  205.  else if( r == type_REAL || r == type_DP || r == type_COMPLEX) {
  206.      warning(operator->line_num,operator->col_num,
  207.        "integer quotient expr converted to real");
  208.  }
  209.  
  210.     }
  211.  
  212.    /* If either term is an identifier, set use flag */
  213.     if(is_true(ID_EXPR,term1->subclass))
  214.  use_variable(term1);
  215.     if(is_true(ID_EXPR,term2->subclass))
  216.  use_variable(term2);
  217.  
  218.   /* Propagate the value of integer constant expressions */
  219.     if(is_true(CONST_EXPR,result->subclass)) {
  220.  if(result_type == type_INTEGER) { /* Only ints propagated */
  221.    int a = int_expr_value(term1),
  222.        b = int_expr_value(term2),
  223.        c;
  224.    switch(op) {
  225.      case '+': c = a+b; break;
  226.      case '-': c = a-b; break;
  227.      case '*': c = a*b; break;
  228.      case '/': if(b == 0) {
  229.    syntax_error(term2->line_num,term2->col_num,
  230.     "division by zero attempted");
  231.    c = 0;
  232.         }
  233.         else {
  234.    c = a/b;
  235.         }
  236.         break;
  237.      case tok_power: c = int_power(a,b); break;
  238.      case tok_AND: c = a&b; break;
  239.      case tok_OR: c = a|b; break;
  240.      case tok_EQV: c = ~(a^b); break;
  241.      case tok_NEQV: c = a^b; break;
  242.      default: fprintf(stderr,"Oops--invalid int expr operator");
  243.    c = 0; break;
  244.    }
  245.  
  246.    result->value.integer = c; /* Result goes into token value */
  247.  }
  248.     }
  249.  
  250. }/*binexpr_type*/
  251.  
  252.  
  253.  /* this routine propagates type in unary expressions */
  254.  
  255. void
  256. unexpr_type(operator,term1,result)
  257.  Token *term1, *operator, *result;
  258. {
  259.    int op = operator->class,
  260.  type1 = datatype_of(term1->class),
  261.  result_type;
  262.  
  263.     if( ! is_computational_type(type1) ) {
  264.   syntax_error(term1->line_num,term1->col_num,
  265.    "noncomputational primary in expression");
  266.   result_type = E;
  267.     }
  268.     else {
  269.  switch(op) {
  270.    /* arith operators: use diagonal of lookup table */
  271.      case '+':
  272.      case '-':
  273.   result_type = arith_expr_type[type1][type1];
  274.   break;
  275.  
  276.     /*  NOT: operand should be
  277.         logical, but allow integers with a
  278.         warning. */
  279.      case tok_NOT:
  280.   if(type1 == L)
  281.       result_type = L;
  282.   else if(type1 == I)
  283.       result_type = W I;
  284.   else
  285.       result_type = E;
  286.   break;
  287.  
  288.      default:
  289.   syntax_error(operator->line_num,operator->col_num,
  290.    "oops: unary operator type not propagated");
  291.   result_type = type1;
  292.   break;
  293.  }
  294.  
  295.  if( type1 != E )
  296.      if( result_type == E) {
  297.   syntax_error(operator->line_num,operator->col_num,
  298.    "type mismatch in expression");
  299.      }
  300.      else if(result_type < 0) {
  301.   warning(operator->line_num,operator->col_num,
  302.    "nonstandard type usage in expression");
  303.   result_type = -result_type;
  304.      }
  305.     }
  306.  
  307.     result->class = type_byte(class_VAR, result_type);
  308.     result->subclass = 0; /* clear all flags */
  309.  
  310.   /* Keep track of constant expressions */
  311.     copy_flag(CONST_EXPR,result->subclass,term1->subclass);
  312.  
  313.   /* Remember if integer division was used */
  314.     if(result_type == type_INTEGER)
  315.      copy_flag(INT_QUOTIENT_EXPR,result->subclass,term1->subclass);
  316.  
  317.     if(is_true(ID_EXPR,term1->subclass))
  318.  use_variable(term1);
  319.  
  320.   /* Propagate the value of integer constant expressions */
  321.     if(is_true(CONST_EXPR,result->subclass)) {
  322.  if(result_type == type_INTEGER) { /* Only ints propagated */
  323.    int a = int_expr_value(term1),
  324.        c;
  325.    switch(op) {
  326.      case '+': c = a; break;
  327.      case '-': c = -a; break;
  328.      case tok_NOT: c = ~a; break;
  329.      default: fprintf(stderr,"Oops--invalid int expr operator");
  330.    c = 0; break;
  331.    }
  332.  
  333.    result->value.integer = c; /* Result goes into token value */
  334.  }
  335.     }
  336. }
  337.  
  338.  /* this routine propagates type in assignment statements */
  339.  
  340. void
  341. assignment_stmt_type(term1,equals,term2)
  342.  Token *term1, *equals, *term2;
  343. {
  344.     int type1 = datatype_of(term1->class),
  345.  type2 = datatype_of(term2->class),
  346.  result_type;
  347.  
  348.  
  349.     if( ! is_computational_type(type1) ) {
  350.   syntax_error(term1->line_num,term1->col_num,
  351.    "noncomputational primary in expression");
  352.   result_type = E;
  353.     }
  354.     else if( ! is_computational_type(type2) ) {
  355.   syntax_error(term2->line_num,term2->col_num,
  356.    "noncomputational primary in expression");
  357.   result_type = E;
  358.     }
  359.     else {
  360.  result_type = assignment_type[type1][type2];
  361.  
  362.  
  363.  if( (type1 != E && type2 != E) )
  364.      if( result_type == E) {
  365.   syntax_error(equals->line_num,equals->col_num,
  366.    "type mismatch in assignment statement");
  367.      }
  368.      else if(result_type < 0) {  /* W result */
  369.   warning(equals->line_num,equals->col_num,
  370.   "nonstandard type combination in assignment statement");
  371.   result_type = -result_type;
  372.      }
  373.      else { /* Watch for truncation to lower precision type */
  374.   if(is_computational_type(result_type) &&
  375.      result_type < type2) {
  376.        warning(equals->line_num,equals->col_num,
  377.          type_name[type2]);
  378.        msg_tail("truncated to");
  379.        msg_tail(type_name[result_type]);
  380.      }
  381.      }
  382.     }
  383.  
  384.  
  385.   /* Issue warning if integer expr involving division is
  386.      later converted to any real type. */
  387.     if( is_true(INT_QUOTIENT_EXPR,term2->subclass) ) {
  388.  
  389.  int r=result_type;
  390.  
  391.  if( r == type_REAL || r == type_DP || r == type_COMPLEX)
  392.      warning(equals->line_num,equals->col_num,
  393.    "integer quotient expr converted to real");
  394.     }
  395.  
  396.  
  397.     if(is_true(ID_EXPR,term2->subclass))
  398.  use_variable(term2);
  399.  
  400.     use_lvalue(term1);
  401. }
  402.  
  403.  /* Make an expression-token for a function invocation */
  404.  
  405. void
  406. func_ref_expr(id,args,result)
  407.  Token *id,*args,*result;
  408. {
  409.  symtab *symt;
  410.  IntrinsInfo *defn;
  411.  int rettype;
  412.  
  413.  symt = hashtab[id->value.integer].loc_symtab;
  414.  
  415.  if( symt->intrinsic ) {
  416.      defn = symt->info.intrins_info;
  417.    /* Intrinsic functions: type stored in info field */
  418.      rettype = defn->result_type;
  419.  
  420.   /* Generic Intrinsic functions: use arg type of 1st arg */
  421.      if(rettype == type_GENERIC) {
  422.   rettype = ( (args->next_token == NULL)?
  423.    type_UNDECL : args->next_token->class );
  424.       /* special case */
  425.   if(rettype == type_COMPLEX && strcmp(symt->name,"ABS") == 0)
  426.    rettype = type_REAL;
  427.      }
  428.  }
  429.  else {
  430.      rettype = get_type(symt);
  431.  }
  432.   /* referencing function makes it no longer a class_SUBPROGRAM
  433.      but an expression. */
  434.  result->class = type_byte(class_VAR,rettype);
  435.  result->subclass = 0; /* clear all flags */
  436. }
  437.  
  438.  
  439.  
  440.   /* Make an expression-token for primary consisting of
  441.      a symbolic name */
  442.  
  443. void
  444. primary_id_expr(id,primary)
  445.  Token *id,*primary;
  446. {
  447.  symtab *symt;
  448.  symt = hashtab[id->value.integer].loc_symtab;
  449.  primary->class = type_byte( storage_class_of(symt->type),
  450.         get_type(symt) );
  451.  primary->subclass = 0;
  452.  
  453.  make_true(ID_EXPR,primary->subclass);
  454.  
  455.  if( storage_class_of(symt->type) == class_VAR) {
  456.   if(symt->parameter) {
  457.       make_true(CONST_EXPR,primary->subclass);
  458.   }
  459.   else {
  460.       make_true(LVALUE_EXPR,primary->subclass);
  461.   }
  462.   if(symt->array_var)
  463.       make_true(ARRAY_ID_EXPR,primary->subclass);
  464.   if(symt->set_flag || symt->common_var || symt->parameter
  465.       || symt->argument)
  466.       make_true(SET_FLAG,primary->subclass);
  467.   if(symt->assigned_flag)
  468.       make_true(ASSIGNED_FLAG,primary->subclass);
  469.   if(symt->used_before_set)
  470.       make_true(USED_BEFORE_SET,primary->subclass);
  471.  }
  472.  else if(storage_class_of(symt->type) == class_STMT_FUNCTION) {
  473.   make_true(STMT_FUNCTION_EXPR,primary->subclass);
  474.  }
  475.  
  476. if(debug_parser){
  477.  fprintf(list_fd,"\nprimary %s: class=0x%x subclass=0x%x",
  478.   symt->name,primary->class,primary->subclass);
  479. }
  480. }
  481.  
  482.  
  483.  /* Integer power: uses recursion x**n = (x**(n/2))**2 */
  484. PRIVATE int
  485. int_power(x,n)
  486.  int x,n;
  487. {
  488.  int temp;
  489.    /* Order of tests puts commonest cases first */
  490.  if(n > 1) {
  491.   temp = int_power(x,n>>1);
  492.   temp *= temp;
  493.   if(n&1) return temp*x; /* Odd n */
  494.   else return temp; /* Even n */
  495.  }
  496.  else if(n == 1) return x;
  497.  else if(n < 0) return 1/int_power(x,-n); /* Usually 0 */
  498.  else return 1;
  499. }
  500.     /* Undefine special macros */
  501. #undef E
  502. #undef I
  503. #undef R
  504. #undef D
  505. #undef C
  506. #undef L
  507. #undef S
  508. #undef H
  509. #undef W
  510.  
  511.  
  512. /* II. */
  513.  
  514. /* project.c:
  515.  Project-file I/O routines.  Routines included:
  516.  
  517.  Shared routines:
  518.     void proj_file_out() writes data from symbol table to project file.
  519.     void proj_file_in() reads data from project file to symbol table.
  520.  
  521.  Private routines:
  522.   int has_defn()     TRUE if external has defn in current file
  523.   int has_call()     TRUE if external has call in current file
  524.   int count_com_defns() Counts multiple common defns.
  525.   void proj_alist_out() Outputs argument lists
  526.   void proj_clist_out() Outputs common lists
  527.   void proj_arg_info_in()  Inputs argument lists
  528.   void proj_com_info_in()  Inputs common lists
  529. */
  530.  
  531. #include <string.h>
  532.  
  533. #ifdef __STDC__
  534. #include <stdlib.h>
  535. #else
  536. char *calloc(),*malloc();
  537. void exit();
  538. #endif
  539.  
  540. /* Note: compilation option PROJ_KEEPALL
  541.  
  542.    Define the symbol PROJ_KEEPALL to make Forchek create project files
  543.    with complete global symbol table information.  Default is to keep
  544.    only subprogram definitions, those external references not defined in
  545.    the current file, and only one instance of each common block.
  546.  
  547.    This flag is useful mainly for debugging purposes.
  548. */
  549.  
  550. PRIVATE int has_defn(), has_call();
  551. PRIVATE void proj_alist_out(),proj_clist_out(),
  552.   proj_arg_info_in(),proj_com_info_in();
  553.  
  554. #ifdef PROJ_KEEPALL
  555. PRIVATE int count_com_defns();
  556. #endif
  557.  
  558.  
  559. PRIVATE int
  560. has_defn(alist)   /* Returns TRUE if list has defns */
  561.    ArgListHeader *alist;
  562. {
  563.   while( alist != NULL && alist->topfile == top_filename ) {
  564.     if(alist->is_defn)
  565.       return TRUE;
  566.     alist = alist->next;
  567.   }
  568.   return FALSE;
  569. }
  570.  
  571.  
  572. PRIVATE int
  573. has_call(alist)  /* Returns TRUE if list has calls or defns  */
  574.    ArgListHeader *alist;
  575. {
  576.   while( alist != NULL && alist->topfile == top_filename) {
  577.     if( alist->is_call || alist->actual_arg )
  578.  return TRUE;
  579.     alist = alist->next;
  580.   }
  581.   return FALSE;
  582. }
  583.  
  584. #ifdef PROJ_KEEPALL
  585. PRIVATE int
  586. count_com_defns(clist)  /* Returns number of common decls in list  */
  587.    ComListHeader *clist;
  588. {
  589.   int count=0;
  590.   while( clist != NULL && clist->topfile == top_filename ) {
  591.     ++count;
  592.     clist = clist->next;
  593.   }
  594.   return count;
  595. }
  596. #endif
  597.  
  598.  /* proj_file_out: writes data from symbol table to project file. */
  599.  
  600. #define WRITE_STR(LEADER,S) (fprintf(fd,LEADER), fprintf(fd," %s",S))
  601. #define WRITE_NUM(LEADER,NUM) (fprintf(fd,LEADER), fprintf(fd," %d",NUM))
  602. #define NEXTLINE fprintf(fd,"\n")
  603.  
  604. void
  605. proj_file_out(fd)
  606.      FILE *fd;
  607. {
  608.   symtab *sym_list[GLOBSYMTABSZ]; /* temp. list of symtab entries to print */
  609.   BYTE sym_has_defn[GLOBSYMTABSZ];
  610.   BYTE sym_has_call[GLOBSYMTABSZ];
  611.  
  612.   if(fd == NULL)
  613.     return;
  614.  
  615.   WRITE_STR("file",top_filename);
  616.   NEXTLINE;
  617.  
  618.   { /* Make list of subprograms defined or referenced in this file */
  619.     int i,numexts,numdefns,numcalls,do_defns,pass;
  620.     ArgListHeader *alist;
  621.     for(i=0,numexts=numdefns=numcalls=0;i<glob_symtab_top;i++) {
  622.       if(storage_class_of(glob_symtab[i].type) == class_SUBPROGRAM &&
  623.  (alist=glob_symtab[i].info.arglist) != NULL) {
  624.    /* Look for defns and calls of this guy. */
  625.  
  626.  if( (sym_has_defn[numexts]=has_defn(alist)) != (BYTE) FALSE )
  627.     numdefns++;
  628.  if( (sym_has_call[numexts]= (has_call(alist)
  629.   /* keep only externals not satisfied in this file */
  630. #ifndef PROJ_KEEPALL
  631.        && !sym_has_defn[numexts]
  632. #endif
  633.       )) != (BYTE) FALSE )
  634.     numcalls++;
  635.  if(sym_has_defn[numexts] || sym_has_call[numexts])
  636.    sym_list[numexts++] = &glob_symtab[i];
  637.       }
  638.     }
  639.  
  640.   /* List all subprogram defns, then all calls */
  641.     for(pass=0,do_defns=TRUE; pass<2; pass++,do_defns=!do_defns) {
  642.  
  643.       if(do_defns)
  644.  WRITE_NUM(" entries",numdefns);
  645.       else
  646.  WRITE_NUM(" externals",numcalls);
  647.       NEXTLINE;
  648.  
  649.       for(i=0; i<numexts; i++) {
  650.  if( (do_defns && sym_has_defn[i]) || (!do_defns && sym_has_call[i]) ){
  651.    if(do_defns)
  652.      WRITE_STR(" entry",sym_list[i]->name);
  653.    else
  654.      WRITE_STR(" external",sym_list[i]->name);
  655.  
  656.    WRITE_NUM(" class",storage_class_of(sym_list[i]->type));
  657.    WRITE_NUM(" type",datatype_of(sym_list[i]->type));
  658.    fprintf(fd," flags %d %d %d %d %d %d %d %d",
  659.     sym_list[i]->used_flag,
  660.     sym_list[i]->set_flag,
  661.     sym_list[i]->invoked_as_func,
  662.     sym_list[i]->declared_external,
  663.     /* N.B. library_module included here but is not restored */
  664.     sym_list[i]->library_module,
  665.     0,0,0); /* for possible future use */
  666.    NEXTLINE;
  667.    proj_alist_out(sym_list[i],fd,do_defns,(int)sym_has_defn[i]);
  668.  }
  669.       }/* end for i */
  670.       NEXTLINE;
  671.     }/*end for pass */
  672.   }
  673.  
  674.   {
  675.     int i,numblocks,numdefns;
  676.     ComListHeader *clist;
  677.     for(i=0,numblocks=numdefns=0;i<glob_symtab_top;i++) {
  678.       if(storage_class_of(glob_symtab[i].type) == class_COMMON_BLOCK
  679.   && (clist=glob_symtab[i].info.comlist) != NULL &&
  680.   clist->topfile == top_filename ) {
  681. #ifdef PROJ_KEEPALL
  682.  numdefns += count_com_defns(clist);
  683. #else    /* No keepall: save only one decl */
  684.  numdefns++;
  685. #endif
  686.  sym_list[numblocks++] = &glob_symtab[i];
  687.       }
  688.     }
  689.     WRITE_NUM(" comblocks",numdefns);
  690.     NEXTLINE;
  691.     for(i=0; i<numblocks; i++) {
  692.       proj_clist_out(sym_list[i],fd);
  693.     }
  694.     NEXTLINE;
  695.   }
  696. }
  697.  
  698.  
  699.  
  700.  
  701.  /* proj_alist_out: writes arglist data from symbol table to
  702.     project file. */
  703.  
  704. PRIVATE void
  705. proj_alist_out(symt,fd,do_defns,locally_defined)
  706.      symtab *symt;
  707.      FILE *fd;
  708.      int do_defns,locally_defined;
  709. {
  710.   ArgListHeader *a=symt->info.arglist;
  711.   ArgListElement *arg;
  712.   int i,n;
  713.   unsigned long diminfo;
  714.  
  715.  
  716.   /* This loop runs thru only those arglists that were
  717.       created in the current top file. */
  718.     while( a != NULL && a->topfile == top_filename) {
  719.   /* do_defns mode: output only definitions */
  720.      if( (do_defns && a->is_defn) || (!do_defns && !a->is_defn) )
  721. #ifndef PROJ_KEEPALL
  722.   /* keep only externals not satisfied in this file */
  723.     if( a->is_defn
  724.        || !locally_defined )
  725. #endif
  726.      {
  727.       if(a->is_defn)
  728.   fprintf(fd," defn\n");
  729.       else
  730.   fprintf(fd," call\n");
  731.  
  732.       WRITE_STR(" module",a->module->name);
  733.       WRITE_STR(" file",a->filename);
  734.       WRITE_NUM(" line",a->line_num);
  735.       WRITE_NUM(" class",storage_class_of(a->type));
  736.       WRITE_NUM(" type",datatype_of(a->type));
  737.       fprintf(fd," flags %d %d %d %d",
  738.        a->is_defn,
  739.        a->is_call,
  740.        a->external_decl,
  741.        a->actual_arg);
  742.       NEXTLINE;
  743.       n=a->numargs;
  744.       if(a->is_defn || a->is_call) {
  745.  WRITE_NUM(" args",n);
  746.  NEXTLINE;
  747.       }
  748.  
  749.       /* Next lines, 1 per argument: type, array dims, array size, flags */
  750.       arg = a->arg_array;
  751.       for(i=0; i<n; i++) {
  752.  WRITE_NUM(" arg",i+1);
  753.  WRITE_NUM(" class",storage_class_of(arg[i].type));
  754.  WRITE_NUM(" type",datatype_of(arg[i].type));
  755.  diminfo = (
  756.      ((storage_class_of(arg[i].type) == class_VAR) &&
  757.      is_computational_type(datatype_of(arg[i].type))) ?
  758.        arg[i].info.array_dim: 0 );
  759.  WRITE_NUM(" dims",array_dims(diminfo));
  760.  WRITE_NUM(" size",array_size(diminfo));
  761.  fprintf(fd," flags %d %d %d %d %d %d %d %d",
  762.   arg[i].is_lvalue,
  763.   arg[i].set_flag,
  764.   arg[i].assigned_flag,
  765.   arg[i].used_before_set,
  766.   arg[i].array_var,
  767.   arg[i].array_element,
  768.   arg[i].declared_external,
  769.   0);  /* possible flag for future use */
  770.  NEXTLINE;
  771.       }
  772.      }/* end if(do_defn...)*/
  773.      a = a->next;
  774.    }/* end while(a!=NULL)*/
  775.    fprintf(fd," end\n");
  776. }/*proj_alist_out*/
  777.  
  778.  
  779.  
  780.  /* proj_clist_out writes common var list data from symbol
  781.     table to project file. */
  782.  
  783. PRIVATE void
  784. proj_clist_out(symt,fd)
  785.      symtab *symt;
  786.      FILE *fd;
  787. {
  788.     ComListHeader *c=symt->info.comlist;
  789.     ComListElement *cvar;
  790.     int i,n;
  791. #ifdef PROJ_KEEPALL
  792.     while   /* keepall: loop thru all defns */
  793. #else
  794.     if    /* no keepall: just save one defn */
  795. #endif
  796.       (c != NULL && c->topfile == top_filename) {
  797.  
  798.       WRITE_STR(" block",symt->name);
  799.       WRITE_NUM(" class",storage_class_of(symt->type));
  800.       WRITE_NUM(" type",datatype_of(symt->type));
  801.       NEXTLINE;
  802.       WRITE_STR(" module",c->module->name);
  803.       WRITE_STR(" file",c->filename);
  804.       WRITE_NUM(" line",c->line_num);
  805.       WRITE_NUM(" flags",c->flags);
  806.       NEXTLINE;
  807.       WRITE_NUM(" vars",n=c->numargs);
  808.       NEXTLINE;
  809.  
  810.     /* Next lines, 1 per variable: class, type, array dims, array size */
  811.       cvar = c->com_list_array;
  812.       for(i=0; i<n; i++) {
  813.  WRITE_NUM(" var",i+1);
  814.  WRITE_NUM(" class",storage_class_of(cvar[i].type));
  815.  WRITE_NUM(" type",datatype_of(cvar[i].type));
  816.  WRITE_NUM(" dims",array_dims(cvar[i].dimen_info));
  817.  WRITE_NUM(" size",array_size(cvar[i].dimen_info));
  818.       NEXTLINE;
  819.       }
  820.       c = c->next;
  821.     }/* end while c != NULL */
  822. }
  823.  
  824. #undef WRITE_STR
  825. #undef WRITE_NUM
  826. #undef NEXTLINE
  827.  
  828.  
  829.  /* proj_file_in:
  830.     Reads a project file, storing info in global symbol table.
  831.     See proj_file_out and its subroutines for the current
  832.     project file format.
  833.   */
  834. #define MAXNAME 127 /* Max string that will be read in: see READ_STR below */
  835.  
  836.  
  837.    /* Macros for error-flagging input */
  838.  
  839. PRIVATE int nil()/* to make lint happy */
  840. { return 0; }
  841.  
  842. #define READ_ERROR (fprintf(stderr,\
  843.      "Oops-- error reading project file at line %d\n",proj_line_num),\
  844.      exit(1),nil())
  845. #define READ_OK nil()
  846.  
  847. #define READ_FIRST_STR(LEADER,STR) (fscanf(fd,LEADER),fscanf(fd,"%127s",STR))
  848. #define READ_STR(LEADER,STR) ((fscanf(fd,LEADER),\
  849.           fscanf(fd,"%127s",STR))==1? READ_OK:READ_ERROR)
  850. #define READ_NUM(LEADER,NUM) ((fscanf(fd,LEADER),\
  851.           fscanf(fd,"%d",&NUM))==1? READ_OK:READ_ERROR)
  852. #define NEXTLINE {int c;while( (c=fgetc(fd)) != EOF && c != '\n') continue;\
  853.       if(c == EOF) READ_ERROR; else ++proj_line_num;}
  854.  
  855.  
  856. int proj_line_num; /* Line number in proj file for diagnostic output */
  857.  
  858. void
  859. proj_file_in(fd)
  860.   FILE *fd;
  861. {
  862.   char buf[MAXNAME+1],*topfilename=NULL;
  863.   int retval;
  864.   unsigned numentries,ientry, numexts,iext, numblocks,iblock;
  865.  
  866.  
  867.   proj_line_num = 1;
  868.  
  869.  while( (retval=READ_FIRST_STR("file",buf)) == 1) {
  870.  
  871.   /* Save filename in permanent storage */
  872.    topfilename = strcpy(malloc(strlen(buf)+1),buf);
  873.    NEXTLINE;
  874. #ifdef DEBUG_PROJECT
  875.  printf("read file %s\n",topfilename);
  876. #endif
  877.  
  878.  
  879.   READ_NUM(" entries",numentries); /* Get no. of entry points */
  880.   NEXTLINE;
  881. #ifdef DEBUG_PROJECT
  882.  printf("read entries %d\n",numentries);
  883. #endif
  884.     /* Read defn arglists */
  885.   for(ientry=0; ientry<numentries; ientry++) {
  886.       proj_arg_info_in(fd,topfilename,TRUE);
  887.   }
  888.   NEXTLINE;
  889.  
  890.   READ_NUM(" externals",numexts); /* Get no. of external refs */
  891. #ifdef DEBUG_PROJECT
  892.  printf("read exts %d\n",numexts);
  893. #endif
  894.   NEXTLINE;
  895.  
  896.     /* Read invocation & ext def arglists */
  897.   for(iext=0; iext<numexts; iext++) {
  898.     proj_arg_info_in(fd,topfilename,FALSE);
  899.   }
  900.   NEXTLINE;
  901.  
  902.  
  903.    /* Read common block info */
  904.  
  905.    READ_NUM(" comblocks",numblocks);
  906. #ifdef DEBUG_PROJECT
  907.  printf("read num blocks %d\n",numblocks);
  908. #endif
  909.    NEXTLINE;
  910.  
  911.    for(iblock=0; iblock<numblocks; iblock++) {
  912.      proj_com_info_in(fd,topfilename);
  913.    }
  914.    NEXTLINE;
  915.  
  916.  }/* end while(retval == 1) */
  917.  
  918.  if(retval != EOF) READ_ERROR;
  919.  
  920.  init_symtab();  /* Clear out local strspace */
  921. }
  922.  
  923. static char *prev_file_name="";/* used to reduce number of callocs */
  924.  
  925.    /* Read arglist info */
  926. PRIVATE void
  927. proj_arg_info_in(fd,filename,is_defn)
  928.     FILE *fd;
  929.     char *filename;  /* name of toplevel file */
  930.     int is_defn;
  931.   {
  932.     char id_name[MAXNAME+1],module_name[MAXNAME+1],sentinel[6];
  933.     char file_name[MAXNAME+1];
  934.     int id_class,id_type;
  935.     unsigned
  936.        id_used_flag,
  937.        id_set_flag,
  938.        id_invoked,
  939.        id_declared,
  940.        id_library_module,
  941.        future1,future2,future3;
  942.  
  943.     unsigned h;
  944.     symtab *gsymt, *module;
  945.     unsigned alist_class,alist_type,alist_is_defn,alist_is_call,
  946.        alist_external_decl,alist_actual_arg;
  947.     unsigned alist_line;
  948.     unsigned numargs,iarg,arg_num,arg_class,arg_type,arg_dims,arg_size;
  949.     unsigned   /* Flags for arguments */
  950.   arg_is_lvalue,
  951.   arg_set_flag,
  952.   arg_assigned_flag,
  953.   arg_used_before_set,
  954.   arg_array_var,
  955.   arg_array_element,
  956.   arg_declared_external,
  957.   arg_future_flag; /* possible flag for future use */
  958.  
  959.     if(is_defn)
  960.  READ_STR(" entry",id_name); /* Entry point name */
  961.     else
  962.  READ_STR(" external",id_name); /* External name */
  963.     READ_NUM(" class",id_class); /* class as in symtab */
  964.     READ_NUM(" type",id_type); /* type as in symtab */
  965.     if(fscanf(fd," flags %d %d %d %d %d %d %d %d",
  966.        &id_used_flag,
  967.        &id_set_flag,
  968.        &id_invoked,
  969.        &id_declared,
  970.        &id_library_module,
  971.        &future1,&future2,&future3) != 8) READ_ERROR;
  972.     NEXTLINE;
  973.  
  974. #ifdef DEBUG_PROJECT
  975.  printf("read id name %s class %d type %d\n",
  976. id_name,id_class,id_type);
  977. #endif
  978.  
  979.     /* Create global symtab entry */
  980.     h = hash_lookup(id_name);
  981.     if( (gsymt = hashtab[h].glob_symtab) == NULL)
  982.       gsymt = install_global(h,id_type,class_SUBPROGRAM);
  983.  
  984.   /* Set library_module flag if project file taken in lib mode */
  985.     if(is_defn && library_mode) {
  986.       gsymt->library_module = TRUE;
  987.     }
  988.  
  989.     if(id_used_flag)
  990.       gsymt->used_flag = TRUE;
  991.     if(id_set_flag)
  992.       gsymt->set_flag = TRUE;
  993.     if(id_invoked)
  994.       gsymt->invoked_as_func = TRUE;
  995.     if(id_declared)
  996.       gsymt->declared_external = TRUE;
  997.   /* library_module not copied, since it usually used to
  998.      suppress messages while making project file. */
  999. /*    if(id_library_module)
  1000. **      gsymt->library_module = TRUE;
  1001. */
  1002.    while(   fscanf(fd,"%5s",sentinel),
  1003. #ifdef DEBUG_PROJECT
  1004.  printf("sentinel=[%s]=%d\n",sentinel,strcmp(sentinel,"more")),
  1005. #endif
  1006.   strcmp(sentinel,(is_defn?"defn":"call")) == 0) {
  1007.       ArgListHeader *ahead;
  1008.       ArgListElement *alist;
  1009.  
  1010.       NEXTLINE;
  1011.  
  1012.       READ_STR(" module",module_name);
  1013.       READ_STR(" file",file_name);
  1014.       READ_NUM(" line",alist_line); /* line number */
  1015.       READ_NUM(" class",alist_class); /* class as in ArgListHeader */
  1016.       READ_NUM(" type",alist_type); /* type as in ArgListHeader */
  1017.       if(fscanf(fd," flags %d %d %d %d",
  1018.   &alist_is_defn,
  1019.   &alist_is_call,
  1020.   &alist_external_decl,
  1021.   &alist_actual_arg) != 4) READ_ERROR;
  1022.       NEXTLINE;
  1023. #ifdef DEBUG_PROJECT
  1024.  printf("read alist class %d type %d line %d\n",
  1025. alist_class,alist_type,alist_line);
  1026. #endif
  1027.   /* Find current module in symtab. If not there, make
  1028.      a global symtab entry for it. It will be filled
  1029.      in eventually when processing corresponding entry.
  1030.    */
  1031.  
  1032.       h = hash_lookup(module_name);
  1033.       if( (module = hashtab[h].glob_symtab) == NULL) {
  1034.  module = install_global(h,type_UNDECL,class_SUBPROGRAM);
  1035.       }
  1036.  
  1037.       if(alist_is_defn || alist_is_call) {
  1038.    READ_NUM(" args",numargs);
  1039.    NEXTLINE;
  1040.       }
  1041.       else
  1042.  numargs = 0;
  1043.  
  1044. #ifdef DEBUG_PROJECT
  1045.  printf("read numargs %d\n",numargs);
  1046. #endif
  1047. /*
  1048. **      if(!is_defn) {
  1049. ** gsymt->used_flag = TRUE;
  1050. **      }
  1051. */
  1052.     /* Create arglist structure */
  1053.       if(((ahead=(ArgListHeader *) calloc(1, sizeof(ArgListHeader)))
  1054.       == (ArgListHeader *) NULL) ||
  1055.    (numargs != 0 &&
  1056.           ((alist=(ArgListElement *) calloc(numargs,sizeof(ArgListElement)))
  1057.      == (ArgListElement *) NULL))){
  1058.   fprintf(stderr, "Oops: Out of space for argument list\n");
  1059.   exit(1);
  1060.       }
  1061.  
  1062.    /* Initialize arglist and link it to symtab */
  1063.       ahead->type = type_byte(alist_class,alist_type);
  1064.       ahead->numargs = numargs;
  1065.       ahead->arg_array = (numargs==0? NULL: alist);
  1066.       ahead->module = module;
  1067.       ahead->topfile = filename;
  1068.    /* try to avoid reallocating space for same name */
  1069.       ahead->filename =
  1070.  (strcmp(file_name,filename)==0? filename:
  1071.   (strcmp(file_name,prev_file_name)==0? prev_file_name:
  1072.    (prev_file_name=strcpy(malloc(strlen(file_name)+1),file_name))));
  1073.  
  1074.       ahead->line_num = alist_line;
  1075.       ahead->is_defn = alist_is_defn;
  1076.       ahead->is_call = alist_is_call;
  1077.       ahead->external_decl = alist_external_decl;
  1078.       ahead->actual_arg = alist_actual_arg;
  1079.       ahead->next = gsymt->info.arglist;
  1080.       gsymt->info.arglist = ahead;
  1081.  
  1082.    /* Fill arglist array from project file */
  1083.       for(iarg=0; iarg<numargs; iarg++) {
  1084.  READ_NUM(" arg",arg_num); if(arg_num != iarg+1) READ_ERROR;
  1085.  READ_NUM(" class",arg_class);
  1086.  READ_NUM(" type",arg_type);
  1087.  READ_NUM(" dims",arg_dims);
  1088.  READ_NUM(" size",arg_size);
  1089.  if(fscanf(fd," flags %d %d %d %d %d %d %d %d",
  1090.   &arg_is_lvalue,
  1091.   &arg_set_flag,
  1092.   &arg_assigned_flag,
  1093.   &arg_used_before_set,
  1094.   &arg_array_var,
  1095.   &arg_array_element,
  1096.   &arg_declared_external,
  1097.   &arg_future_flag) != 8) READ_ERROR;
  1098.  
  1099.  alist[iarg].info.array_dim = array_dim_info(arg_dims,arg_size);
  1100.  alist[iarg].type = type_byte(arg_class,arg_type);
  1101.  alist[iarg].is_lvalue = arg_is_lvalue;
  1102.  alist[iarg].set_flag = arg_set_flag;
  1103.  alist[iarg].assigned_flag = arg_assigned_flag;
  1104.  alist[iarg].used_before_set = arg_used_before_set;
  1105.  alist[iarg].array_var = arg_array_var;
  1106.  alist[iarg].array_element = arg_array_element;
  1107.  alist[iarg].declared_external = arg_declared_external;
  1108.  NEXTLINE;
  1109. #ifdef DEBUG_PROJECT
  1110.  printf("read arg num %d\n",arg_num);
  1111. #endif
  1112.       }
  1113.  
  1114.     }/* end while( sentinel == "defn"|"call") */
  1115.  
  1116.     if(strcmp(sentinel,"end") != 0) READ_ERROR;
  1117.     NEXTLINE;
  1118. }
  1119.  
  1120.  
  1121. PRIVATE void
  1122. proj_com_info_in(fd,filename)
  1123.      FILE *fd;
  1124.      char *filename;
  1125. {
  1126.     char id_name[MAXNAME+1],module_name[MAXNAME+1];
  1127.     char file_name[MAXNAME+1];
  1128.     unsigned id_class,id_type;
  1129.     unsigned clist_flags,clist_line;
  1130.     unsigned numvars,ivar,var_num,var_class,var_type,var_dims,var_size;
  1131.  
  1132.       unsigned h;
  1133.       symtab *gsymt, *module;
  1134.       ComListHeader *chead;
  1135.       ComListElement *clist;
  1136.  
  1137.  
  1138.     READ_STR(" block",id_name);
  1139.     READ_NUM(" class",id_class);
  1140.     READ_NUM(" type",id_type);
  1141. #ifdef DEBUG_PROJECT
  1142.  printf("read com name %s class %d type %d\n",
  1143. id_name,id_class,id_type);
  1144. #endif
  1145.     NEXTLINE;
  1146.  
  1147.     READ_STR(" module",module_name);
  1148.     READ_STR(" file",file_name);
  1149.     READ_NUM(" line",clist_line);
  1150.     READ_NUM(" flags",clist_flags);
  1151.     NEXTLINE;
  1152.  
  1153.     READ_NUM(" vars",numvars);
  1154. #ifdef DEBUG_PROJECT
  1155.  printf("read flags %d line %d\n",clist_flags,clist_line);
  1156. #endif
  1157.     NEXTLINE;
  1158.     /* Create global symtab entry */
  1159.     h = hash_lookup(id_name);
  1160.     if( (gsymt = hashtab[h].com_glob_symtab) == NULL)
  1161.       gsymt = install_global(h,id_type,id_class);
  1162.  
  1163.  
  1164.     /* Create arglist structure */
  1165.     if(((chead=(ComListHeader *) calloc(1, sizeof(ComListHeader)))
  1166.       == (ComListHeader *) NULL) ||
  1167.    (numvars != 0 &&
  1168.           ((clist=(ComListElement *) calloc(numvars,sizeof(ComListElement)))
  1169.      == (ComListElement *) NULL))){
  1170.   fprintf(stderr, "Oops: Out of space for common list\n");
  1171.   exit(1);
  1172.       }
  1173.  
  1174.   /* Find current module in symtab. If not there, make
  1175.      a global symtab entry for it.  This is bogus, since
  1176.      all modules should have been defined previously. */
  1177.  
  1178.       h = hash_lookup(module_name);
  1179.       if( (module = hashtab[h].glob_symtab) == NULL) {
  1180.  fprintf(stderr,"\nWarning-- something's bogus in project file\n");
  1181.  module = install_global(h,type_UNDECL,class_SUBPROGRAM);
  1182.       }
  1183.  
  1184.    /* Initialize arglist and link it to symtab */
  1185.       chead->numargs = numvars;
  1186.       chead->flags = clist_flags;
  1187.       chead->line_num = clist_line;
  1188.       chead->com_list_array = (numvars==0? NULL: clist);
  1189.       chead->module = module;
  1190.       chead->topfile = filename;
  1191.    /* try to avoid reallocating space for same name */
  1192.       chead->filename =
  1193.  (strcmp(file_name,filename)==0? filename:
  1194.   (strcmp(file_name,prev_file_name)==0? prev_file_name:
  1195.    (prev_file_name=strcpy(malloc(strlen(file_name)+1),file_name))));
  1196.  
  1197.       chead->next = gsymt->info.comlist;
  1198.       gsymt->info.comlist = chead;
  1199.  
  1200.    /* Fill comlist array from project file */
  1201.     for(ivar=0; ivar<numvars; ivar++) {
  1202.       READ_NUM(" var",var_num); if(var_num != ivar+1) READ_ERROR;
  1203.       READ_NUM(" class",var_class);
  1204.       READ_NUM(" type",var_type);
  1205.       READ_NUM(" dims",var_dims);
  1206.       READ_NUM(" size",var_size);
  1207.       NEXTLINE;
  1208. #ifdef DEBUG_PROJECT
  1209.  printf("read class %d type %d dims %d size %d\n",var_class,var_type,
  1210. var_dims,var_size);
  1211. #endif
  1212.       clist[ivar].dimen_info = array_dim_info(var_dims,var_size);
  1213.       clist[ivar].type = type_byte(var_class,var_type);
  1214.     }
  1215. }/*proj_com_info_in*/
  1216.  
  1217.